;;###########################################################################
;; dataobj5.lsp
;; Copyright (c) 1991-2002 by Forrest W. Young
;; This file contains code to create emulated table data object proto
;; Implements classification and category data types.
;; Replaces code commented out of dataobj4
;;###########################################################################



(defmeth mv-data-object-proto :ancestors ()
  (ancestors self))

(defun send-data-to-excel () 
  (send *current-data* :send-data-to-excel))

(defmeth mv-data-object-proto :send-data-to-excel ()
  (send self :export-data "exportemp.txt")
  (let* ((file2-path-name 
          (strcat (get-working-directory) separator "exportemp.txt"))
         (helper.exe (strcat *prgfil-path* "Microsoft Office\\Office\\excel.exe"))
         (file1-path-name)
         (command-string))
    (setf *excel.exe* helper.exe)
    (set-working-directory (strcat *default-path* "startup" separator))
    (setf file1-path-name (strcat (get-working-directory) separator "excelvista.xls"))
    (setf command-string (strcat helper.exe 
                                 " \"" file1-path-name ", " file2-path-name "\""))
    (system (strcat *excel.exe* " \"" file1-path-name "\" \"" file2-path-name "\""))
    ))


(defun emulate-table-data (response-variable-name mvdob)
  (send emulated-table-data-object-proto :new response-variable-name mvdob)
  )

(defproto emulated-table-data-object-proto 
  '(classes nways nclasses ncells cellfreqs source-names level-names 
            indicator-matrices obs-labels labels mvdataobj short-cell-labels
            incomplete-data-error-flag) 
  () mv-data-object-proto)

(defmeth emulated-table-data-object-proto :incomplete-data-error-flag 
  (&optional (logical nil set))
  (if set (setf (slot-value 'incomplete-data-error-flag) logical))
  (slot-value 'incomplete-data-error-flag)) 

(defmeth emulated-table-data-object-proto :isnew 
  (response-variable-name mvdob )
;revised fwy: if response-variable-name is nil then creates emulated table data object
;for categorical data with dummy response variable.
;returns nil when data are incomplete.
  (let* ((incomplete-data-error-flag nil)
         (resp-var? response-variable-name)
         (cat-matrix (send mvdob :active-data-matrix '(category)))
         (cat-variables  (send mvdob :active-variables '(category)))
         (cell-labels-and-short-labels 
          (send self :make-cell-labels cat-matrix cat-variables))
         (nobs (first (size cat-matrix)))
         (ungrouped-resp-var 
          (if response-variable-name
              (send mvdob :variable response-variable-name)
              (iseq nobs)))
         (response-variable-name
          (if response-variable-name response-variable-name "NoRespVar"))
       ; (nobs (length ungrouped-resp-var))
         (data-mat (bind-columns ungrouped-resp-var cat-matrix))
         (sorted-labels-and-grouped-data 
          (send self :sort-labels-and-group-data 
                cell-labels-and-short-labels data-mat))
         (data-table (second sorted-labels-and-grouped-data))
         (short-cell-labels
          (remove-duplicates (last sorted-labels-and-grouped-data) 
                             :test 'equal))
         (cell-labels 
          (remove-duplicates (first sorted-labels-and-grouped-data) 
                             :test 'equal)))
    (send self :data-table data-table)
    (send self :data-table-response-variable-name response-variable-name)
    (send self :data-table-sorted-ungrouped-data-matrix
                           (fourth sorted-labels-and-grouped-data))
    (send self :classes    (third sorted-labels-and-grouped-data))
    (if resp-var?
        (when (/= (length (send self :data-table))
                  (apply #'* (mapcar #'length (send self :classes))))
              (send self :incomplete-data-error-flag t)
              (setf incomplete-data-error-flag t)))
    (when (not incomplete-data-error-flag)
          (send self :labels (send mvdob :labels))
          (send self :obs-labels (first sorted-labels-and-grouped-data))
          (send self :nways (length cat-variables))
          (send self :nobs (send mvdob :nobs))    
          (send self :title (send mvdob :title))
          
          (cond 
            (resp-var? 
             ;this code seems as though it is very wrong
             ;it ignores passive variables
             (send self :data (send mvdob :data))
             (send self :nvar (send mvdob :nvar))
             (send self :var-states (send mvdob :var-states))
             (send self :slot-value 'vnames (send mvdob :slot-value 'vnames))
             (send self :slot-value 'vtypes (send mvdob :slot-value 'vtypes)))
            (t
             
             (send self :data (combine (bind-columns 
                                        (send mvdob :active-data-matrix '(all))
                                        ungrouped-resp-var)))
             (send self :nvar (1+ (send mvdob :active-nvar '(all))))
             (send self :var-states (repeat 'selected (send self :nvar)))
             (send self :slot-value 'vnames (combine (send mvdob :active-variables '(all))
                                                     response-variable-name))
             (send self :slot-value 'vtypes (combine (send mvdob :active-types '(all))
                                                     "Numeric"))
             ))
          
          (send self :obs-states (send mvdob :obs-states))
          (send self :slot-value 'onames (send mvdob :slot-value 'onames))
          (send self :name (send mvdob :name))
          (send self :ways cat-variables)
          (send self :ncells (length data-table))
          (send self :nclasses (mapcar #'length (send self :classes)))
          (send self :cellfreqs 
                (if resp-var?
                    (mapcar #'length data-table)
                    ;next one works with incomplete data!
                    (combine (first (send mvdob :convert-category-to-freq)))
                    ))
          ;(send self :cellfreqs (mapcar #'length data-table))
          (send self :cell-labels cell-labels)
          (send self :make-source-names)
          (send self :make-level-names)
          (send self :make-indicator-matrix-list)
          (send self :mvdataobj mvdob))
    self))

(defmeth emulated-table-data-object-proto :data-table (&optional (list nil set))
"Message args: (&optional data-list)
 Sets or retrieves the multivariate data as a list of emulated table cell lists."
  (if set (setf (slot-value 'data-table) list))
  (slot-value 'data-table))

(defmeth emulated-table-data-object-proto :data-table-response-variable-name (&optional (string nil set))
"Message args: (&optional data-list)
 Sets or retrieves the emulated data table response variable name."
  (if set (setf (slot-value 'data-table-response-variable-name) string))
  (slot-value 'data-table-response-variable-name))

(defmeth emulated-table-data-object-proto :data-table-sorted-ungrouped-data-matrix 
  (&optional (list nil set))
"Message args: (&optional data-list)
 Sets or retrieves the data matrix with rows sorted into order for table."
  (if set (setf (slot-value 'data-table-sorted-ungrouped-data-matrix) list))
  (slot-value 'data-table-sorted-ungrouped-data-matrix))

(defmeth emulated-table-data-object-proto :nways
  (&optional (number nil set))
"Message args: (&optional number)
 Sets or retrieves the number of table cells." 
  (if set (setf (slot-value 'nways) number))
  (slot-value 'nways))

(defmeth emulated-table-data-object-proto :nclasses
  (&optional (number-list nil set))
"Message args: (&optional number-list)
 Sets or retrieves a list of the number of classes in each way of the table." 
  (if set (setf (slot-value 'nclasses) number-list))
  (slot-value 'nclasses))

(defmeth emulated-table-data-object-proto :ncells
  (&optional (number nil set))
"Message args: (&optional number)
 Sets or retrieves the number of table ways." 
  (if set (setf (slot-value 'ncells) number))
  (slot-value 'ncells))

(defmeth emulated-table-data-object-proto :cellfreqs
  (&optional (number-list nil set))
"Message args: (&optional number-list)
 Sets or retrieves a list of the number of observations in each cell of the table." 
  (if set (setf (slot-value 'cellfreqs) number-list))
  (slot-value 'cellfreqs))

(defmeth emulated-table-data-object-proto :classes (&optional (string-list nil set))
"Message args: (&optional string-list)
 Sets or retrieves the names of the classes of each way of the table data. This is a list for one-way data and a list of lists for multi-way data.  In the latter case there is a list for each way of the data.  The number of ways and the number of levels of each way are determined from this information."
  (if set (setf (slot-value 'classes) string-list))
  (slot-value 'classes))

(defmeth emulated-table-data-object-proto :source-names
  (&optional (name-list nil set))
"Message args: (&optional name-list)
 Sets or retrieves a list of the main and two-way source names of the table." 
  (if set (setf (slot-value 'source-names) name-list))
  (slot-value 'source-names))

(defmeth emulated-table-data-object-proto :level-names
  (&optional (name-list nil set))
"Message args: (&optional name-list)
 Sets or retrieves a list of lists the table's main and two-way level names." 
  (if set (setf (slot-value 'level-names) name-list))
  (slot-value 'level-names))

(defmeth emulated-table-data-object-proto :labels
  (&optional (strings nil set))
"Message args: (&optional labels)
 Sets or retrieves a list of cell labels." 
  (if set (setf (slot-value 'labels) strings))
  (slot-value 'labels))

(defmeth emulated-table-data-object-proto :obs-labels
  (&optional (string-list nil set))
"Message args: (&optional string-list)
 Sets or retrieves a list of the observation labels." 
  (if set (setf (slot-value 'obs-labels) string-list))
  (slot-value 'obs-labels))

(defmeth emulated-table-data-object-proto :cell-labels
  (&optional (string-list nil set))
"Message args: (&optional string-list)
 Sets or retrieves a list of the cell labels." 
  (if set (setf (slot-value 'cell-labels) string-list))
  (slot-value 'cell-labels))

(defmeth emulated-table-data-object-proto :indicator-matrices
  (&optional (matrix-list nil set))
"Message args: (&optional matrix-list)
 Sets or retrieves a list of the main and two-way indicator matrices." 
  (if set (setf (slot-value 'indicator-matrices) matrix-list))
  (slot-value 'indicator-matrices))

(defmeth emulated-table-data-object-proto :mvdataobj (&optional (objid nil set))
"Message args: (&optional objid)
 Sets or retrieves the classification data object for this table data object."
  (if set (setf (slot-value 'mvdataobj) objid))
  (slot-value 'mvdataobj))

(defmeth emulated-table-data-object-proto :make-cell-labels 
  (cat-matrix cat-variables)
  (let ((row nil)
        (labels nil)
        (short-labels nil)
        (string "")
        (short-string "{")
        (nobs (first (size cat-matrix)))
        (nvar (second (size cat-matrix)))
        (value nil)
        (short-value nil))
    (dotimes 
     (i nobs)
     (setf string "")
     (setf short-string "[")
     (dotimes 
      (j nvar)
      (setf value (select cat-matrix i j))
      (when (numberp value) 
            (setf value (format nil "~s" (select cat-matrix i j))))
      (setf short-string (strcat short-string value (if (= j (1- nvar)) "]" "-")))
      (setf string (strcat string 
           (select cat-variables j) "[" value "]")))
     (setf short-labels (add-element-to-list short-labels short-string))
     (setf labels (add-element-to-list labels string)))
    (list labels short-labels)))

(defmeth emulated-table-data-object-proto :sort-labels-and-group-data
  (cell-labels ungrouped-data)
"Args: cell-labels ungrouped-data
Cells-labels is a list of a list of cell-labels and a list of short-cell-labels. Ungrouped-data is a data-matrix. Sorts cell-labels into order and permutes short-cell-labels accordingly. Uses the sorted cell-labels to make a new table data cell list and classes list . Returns a list with five elements. The elements are the sorted cell-labels, the data cell list, the sorted classes list, a matrix of the sorted ungrouped data, and a list of permuted short-cell-labels."
  (let* ((sorted-table (sort-and-permute-dob 
                        ungrouped-data (second cell-labels) (first cell-labels) nil))
         (sorted-data (first sorted-table))
         (sorted-resp-var (combine (col sorted-data 0)))
         (sorted-labels (second sorted-table))
         (sorted-short-cell-labels (third sorted-table)) 
         (nobs (length sorted-labels))
         (nways (1- (second (size ungrouped-data)))) 
         (data-cell-list nil)
         (classes-list nil)
         (start 0)
         (finish nil)) 
    (dotimes (i (1- nobs))
       (when (not (equal (select sorted-labels i) 
                         (select sorted-labels (1+ i))))
             (setf finish i)
             (setf data-cell-list (add-element-to-list data-cell-list 
                          (select sorted-resp-var (iseq start finish))))
             (setf start (1+ i))))
    (setf data-cell-list (add-element-to-list data-cell-list 
                         (select sorted-resp-var (iseq start (1- nobs)))))
    (dotimes (i nways)
             (setf classes-list (add-element-to-list classes-list
                   (remove-duplicates (combine (col sorted-data (1+ i)))
                                  :test 'equal))))
    (list sorted-labels data-cell-list classes-list 
          (first sorted-table) sorted-short-cell-labels)))


(defmeth emulated-table-data-object-proto :make-source-names ()
"Method args: none
Creates and concatenates two-way table names to way names and stores as source names."
  (let* ((source-names (send self :ways))
         (nways (send self :nways))
         (knt nways))
    (when (> nways 1)
          (setf source-names 
                (combine source-names 
                         (repeat " " (/ (* nways (- nways 1)) 2))))
          (dotimes (i (- nways 1))
                   (dolist (j (iseq (+ i 1) (- nways 1)))
                           (setf (select source-names knt)
                                 (strcat (select source-names i) "*"
                                         (select source-names j)))
                           (setf knt (+ knt 1)))))
    (send self :source-names source-names)))

(defmeth emulated-table-data-object-proto :make-level-names (&optional long)
"Method args: LONG
Makes the table's short or LONG main and two-way level names."
  (let ((names nil)
        (inter-names nil)
        (nclasseslist (send self :nclasses))
        (classes (send self :classes))
        (ways (send self :ways))
        (nways (send self :nways))
        (nclasses nil))
;make main effects level names
    (dotimes (i (send self :nways))
             (setf nclasses (nth i nclasseslist))
             (dotimes (j nclasses)
                      (when (numberp (select (select classes i) j))
                            (setf (select (select classes i) j)
                                  (format nil "~s" 
                                          (select (select classes i) j)))))
             (setf names (add-element-to-list names 
                   (if long
                       (mapcar #'strcat 
                               (repeat (nth i ways) nclasses)
                               (repeat "[" nclasses)
                               (nth i classes)
                               (repeat "]" nclasses))
                       (nth i classes)
                       ))))
;make two-way interaction level names
    (dotimes (m (- nways 1))
       (dolist  (n (iseq (+ m 1) (- nways 1)))
          (setf inter-names nil)
          (dotimes (i (select nclasseslist m))
             (dotimes (j (select nclasseslist n))
                (setf inter-names 
                      (add-element-to-list 
                       inter-names 
                       (strcat (select (select names m) i)
                               "*"
                               (select (select names n) j))))))
                (setf names (add-element-to-list names inter-names))))
    (send self :level-names names)))


(defmeth emulated-table-data-object-proto :make-indicator-matrix-list ()
"Makes a list of indicator matrices for the main effects and (when appropriate) two-way interactions for a data table."
 (send self :make-main-effects-matrices)
 (when (> (send self :nways) 1) (send self :make-interaction-matrices))
  )
 
(defmeth emulated-table-data-object-proto :make-main-effects-matrices ()
"Computes a list of indicator matrices for the main effects of balanced or unbalanced tabular data having any number of ways. Each indicator matrix has one row for each observation and a column for each level. Their elements are 1's and 0's, with a 1 indicating which level the observation belongs in."
  (let* ((nways (send self :nways))
         (cellfreqs (send self :cellfreqs))
         (nobs  (sum cellfreqs))
         (freqs nobs)
         (nlevels (send self :nclasses))
         (nthislevel nil)
         (nproduct 1)
         (nrepeats 1)
         (thisobs 0)
         (thiscell 0)
         (thisfreq 0)
         (design nil))
    (dotimes (i nways)
             (setf nproduct (* nproduct (select nlevels i))))
    (dotimes (i nways)
;determine cell frequencies for way i of the design
             (setf nthislevel (select nlevels i))
             (setf nproduct (/ nproduct nthislevel))
             (setf freqs (repeat 0 (* nthislevel nrepeats)))
             (dotimes (ii (* nthislevel nrepeats))
                      (dotimes (jj nproduct)
                               (setf (select freqs ii) 
                                     (+ (select freqs ii)
                                        (select cellfreqs thiscell)))
                               (setf thiscell (+ thiscell 1))))
             (setf thiscell 0)
;create reduced-rank indicator matrix for way i of the design
             
             (setf design 
                   (make-array (list nobs nthislevel) :initial-element 0))
             (dotimes (k nrepeats)
                      (dotimes (j nthislevel)
                               (dotimes (l (select freqs thisfreq))
                                        (setf (aref design thisobs j) 1)
                                        (setf thisobs (+ thisobs 1)))
                               (setf thisfreq (+ thisfreq 1))))
             (setf nrepeats (* nrepeats nthislevel))
             (send self :indicator-matrices 
                   (make-matrix-list (send self :indicator-matrices) design))
             (setf thisobs 0)
             (setf thisfreq 0)
             )))

(defmeth emulated-table-data-object-proto :make-interaction-matrices ()
"Args: none
Computes and saves in a slot all two-way interaction indicator matrices."
  (let ((n (send self :nways))
        (interaction-matrices nil))
    (when (> n 1)
          (dolist (i (iseq (- n 1)))
             (dolist (j (iseq (+ i 1) (- n 1)))
                (setf interaction-matrices
                      (make-matrix-list 
                       interaction-matrices
                       (send self :twoway-interaction-matrix j i)))))
          (send self :indicator-matrices
                (append (send self :indicator-matrices)
                        interaction-matrices))
          )))

(defmeth emulated-table-data-object-proto :nclass-combinations ()
  (let* ((nclass-combinations (mapcar #'length (send self :classes)))
         (n (length nclass-combinations))
         (result (mapcar #'list  nclass-combinations))
         )
    (dotimes (i (1- n))
             (dolist (j (iseq (1+ i) (1- n)))
                     (setf result 
                           (add-element-to-list 
                            result 
                            (list (select nclass-combinations i)
                                  (select nclass-combinations j))))))
    result))
                      

(defmeth emulated-table-data-object-proto :twoway-interaction-matrix (wayi wayj)
"Args: WAYI WAYJ
WAYI and WAYJ are integers specifying a way of the design.  
Returns the WAYI WAYJ two-way interaction indicator matrix."
  (let ((indicatori  (select (send self :indicator-matrices) wayi))
        (indicatorj  (select (send self :indicator-matrices) wayj))
        (classesi (select (send self :nclasses) wayi))
        (classesj (select (send self :nclasses) wayj))
        (interact nil)
        (nobs     (send self :nobs))
        (interaction nil))
    (dotimes (i classesj)
             (setf interaction (make-matrix-list interaction (transpose 
                   (matrix (list classesi nobs)
                           (map-elements #'* 
                                   (repeat (col indicatorj i) classesi) 
                                         (transpose indicatori)))))))
    (apply #'bind-columns interaction)))

(defmeth emulated-table-data-object-proto :grouped-data (source)
  (let* ((data (combine (send self :data-table)))
         (indicator (nth source (send self :indicator-matrices)))
         (nclasses (second (size indicator)))
         (members nil)
         (grouped-data nil))
    (dotimes (i nclasses)
             (setf members (select data (which (= 1 (col indicator i)))))
             (setf grouped-data (append grouped-data (list members))))
    grouped-data))

(defmeth emulated-table-data-object-proto :grouped-labels (source)
  (let* (
         (labels (send self :obs-labels))
         (indicator (nth source (send self :indicator-matrices)))
         (nclasses (second (size indicator)))
         (members nil)
         (grouped-labels nil))
    (dotimes (i nclasses)
             (setf members (select labels (which (= 1 (col indicator i)))))
             (setf grouped-labels (append grouped-labels (list members))))
    grouped-labels))

(defmeth emulated-table-data-object-proto :table-details (w)
  (let* ((cellnames (send self :cell-labels))
         (cellfreqs (send self :cellfreqs))
         (ncells (send self :ncells))
         (nobs (send self :nobs))
         (ways (send self :ways))
         (nways (send self :nways))
         (classes (send self :classes))
         (balanced (= 1 (length (remove-duplicates cellfreqs)))))
    (display-string 
     (format nil "~2%Category Variables:     ~a~%" ways) w)
    (display-string 
     (format nil "Category Names:         ~a" (first classes)) w)
    (when (> nways 1)
          (dotimes (i (- nways 1))
                   (display-string (format nil " ~a" 
                                           (select classes (+ i 1))) w)))
    (display-string (format nil "~%") w)
    (display-string (format nil "Number of Observations: ~d~%" nobs) w)
    (display-string (format nil "Number of Cells:        ~d~%" ncells) w)
 ;  (display-string (format nil "Data Cell Names:        ~d~%" cellnames) w)
    (display-string (format nil "Data Cell Frequencies:  ~f~%" cellfreqs) w)
    (display-string (format nil "Data Type:              ") w)
    (if balanced (display-string (format nil "Balanced~%") w)
        (display-string (format nil "Unbalanced~%") w))))

(defmeth emulated-table-data-object-proto :table-summary 
  (header resp-var w &key moments quartiles ranges dialog)
"Method Args: (&key moments quartiles ranges dialog)
Prints summary statistics for each cell of the data table.  If dialog is t a dialog box is presented to determine which statistics are to be printed, otherwise the other keywords determine which are printed."
  (let* ((resp-var (send self :data-table-response-variable-name))
        (univals (unique-values (send self :cellfreqs)))
        (quar-rang (or quartiles ranges))
        (summary-options (list (delete 'nil (list
             (when moments '0) (when quar-rang '1))))))
    (when header (send self :table-details w))
    (unless (and (= 1 (first univals)) (= (length univals) 1))
    (when summary-options
          (when (not (select summary-options 0))
                (setf summary-options (send self :summary-option-states)))
          (when summary-options 
                (when (select summary-options 0)
                      (send self :summary-option-states summary-options)
                      (send self :describe-data 
                            (send self :data-table) (send self :cell-labels)
                            summary-options :table resp-var :window w)))))
    (send w :fit-window-to-text)
    ))

(defmeth emulated-table-data-object-proto :table-report 
  (resp-var w header &optional ok-types)
  (let* ((data (send self :data-table))
         (cellnames (send self :cell-labels))
         (cellfreqs (send self :cellfreqs))
         (ncells (send self :ncells))
         (nobs (send self :nobs))
         (ways (send self :ways))
         (nways (send self :nways))
         (classes (send self :classes))
         (nclasses (send self :nclasses))
         (balanced (= 1 (length (remove-duplicates cellfreqs))))
         (header-string "")
         )
    (when header (send self :table-details w))
    (display-string
          (format nil "~%Values of ~a in Each Data Cell~%" resp-var) w)
    (dotimes (i ncells)
             (display-string (format nil "~a  ~10,2f~%"(select cellnames i)
                                     (select data i)) w))
    w))

